System Booster/System Booster.iso/Archives/ARexxTools/ScionRexx.lha/GEDCOM2Scion.rexx

OS/2 REXX Batch file | 1995-11-18 | 42.2 KB | 1,328 lines

/****************************************************************************
 *                                                                          *
 *                                                                          *
 * $VER: GEDCOM2Scion.rexx 2.22 (17 Nov 1995)
 *                                                                          *
 *                      Written by Freddy Ariës                             *
 * Address: Lindeboomweg 7, NL-7135 KE Harreveld, The Netherlands.          *
 *                                                                          *
 * This program was created to import GEDCOM data into the Scion database.  *
 * It should work pretty good by now, although no guarantees whatsoever     *
 * are made. If you have problems using this script, please contact me, and *
 * describe exactly what the problem is, or better yet, send me a copy of   *
 * the GEDCOM file you are trying to read), and I will try to fix it.       *
 *                                                                          *
 * GEDCOM was developed by the Family History Department of the Church of   *
 * Jesus Christ of Latter-day Saints to provide a flexible uniform format   *
 * for exchanging computerized genealogical data.  GEDCOM is an acronym for *
 * GEnealogical Data COMmunication.  GEDCOM is provided to foster the       *
 * sharing of genealogical information and the development of a wide range  *
 * of inter-operable software products to assist genealogists, historians,  *
 * and other researchers.                                                   *
 *                                                                          *
 * + SCION must be running for this AREXX script to work.                   *
 * + This script uses (by default) the rexxreqtools.library (which requires *
 *   a version of reqtools larger than 2.0 and rexxsyslib.library).         *
 *   If you do not have these, run SetDefaults.rexx to change the settings. *
 * + Even though this script does no parsing of dates, it's safer if they   *
 *   are in the exact format "DD MMM YYYY".                                 *
 *                                                                          *
 * DONE: - progress indicator, using rexxarplib.library (requested by       *
 *         Robbie J. Akins himself).                                        *
 *       - now also recognizes full formal tag-names... due to the way eg.  *
 *         Family Tree Maker for Windows creates its (PAF) GEDCOM output.   *
 *       - should now correctly parse files containing ^M (carriage return) *
 *         characters (usually MS-DOS ASCII files that weren't stripped).   *
 *       - creation of external note files for multi-line GEDCOM comments   *
 *         (option)                                                         *
 *       - use of SOUR structure data for the Reference fields (currently   *
 *         not very smart)                                                  *
 *       - now uses preference file for default settings                    *
 *                                                                          *
 * All unrecognized fields or fields that Scion doesn't use, are skipped.   *
 * NOTES:                                                                   *
 * + The program generates a file FILENAME.log (where FILENAME is the       *
 *  name of the GEDCOM file read), in the directory where the GEDCOM file   *
 *  is located. This .log file contains parsing info about which lines were *
 *  skipped and which non-fatal errors were encountered. It may be a good   *
 *  idea to read this file!                                                 *
 * + FAMS and FAMC fields, and EVEN structures will always be skipped,      *
 *  because I use another method of establishing family (spouse & children) *
 *  relationships. If no relationships are established, this probably means *
 *  that the imported file does not support that other method. If you       *
 *  encounter such a file, please send it to me, and tell me what program   *
 *  generated it. If this happens a lot, I will add support for the parsing *
 *  of these relations in a future version.                                 *
 * + If you see strange strings in the Reference fields (eg. something like *
 *  "R1"), you may be able to find more reference information in the GEDCOM *
 *  file in the SOUR structure with that reference number (eg. @R1@).       *
 *                                                                          *
 * TO DO (but low priority, unless someone really wants this [?]):          *
 *  - Add Shell options for the processing of note files                    *
 *  - More intelligent processing of SOUR structures for Reference fields   *
 *  - Add support for other character sets (like the ANSEL format that is   *
 *    described in the GEDCOM specification) [external conversion program?] *
 *  - More intelligent parsing of dates, and a method to handle dates with  *
 *    more than 12 characters                                               *
 *  - Add support for EVEN(t) structures                                    *
 *  - Maybe someday even a way to allow modifying an existing database.     *
 *    The current version will only add to a database, and doesn't care for *
 *    double entries. Don't hold your breath for this one, though!          *
 *  - Suggestions, comments, bugreports, donations, etc. are appreciated.   *
 *                                                                          *
 ****************************************************************************/

options failat 20; options results
arg inname inval

versionstr = "2.22"

/* Don't change the settings here! Run SetDefaults.rexx instead! */
usereq = 1; prgrs = 1; pgopen = 0; outp = 1
scrdev = stdout
PSCR = "SCIONGEN"
notesdir = ""

scrname = "CON:0//639//Scion Output/AUTO/SCREEN"
donotes = 0; lnum = 0
NL = '0A'x

signal on IOERR

do while inname = '?'
  writeln(stdout, "INFILE/A,QUIET/S,NOREQ/S ")
  pull inname inval
end

/* read preferences file */

if open(pfile, 'ENV:Scion/ScionRexx.prefs', 'r') then do
  do while ~eof(pfile)
    inln = readln(pfile)
    if inln ~= "" then do
      wstr = upper(word(inln, 1))
      if wstr = "NOTES" then
        notesdir = strip(delstr(inln, 1, length(wstr)), 'b', ' "')
      else if wstr = "USEREQ" then
        usereq = 1
      else if wstr = "NOUSEREQ" then
        usereq = 0
      else if wstr = "PROGRESS" then
        prgrs = 1
      else if wstr = "NOPROGRESS" then
        prgrs = 0
      else if wstr = "PUBSCREEN" then
        pscr = strip(delstr(inln, 1, length(wstr)), 'b', ' "')
    end
  end
  close(pfile)
end

if pscr = "" | (pscr ~= "WORKBENCH" & ~show('p', pscr)) then
  pscr = "SCIONGEN"
wstr = right(notesdir, 1)
if wstr ~= '/' & wstr ~= ':' then notesdir = ""
scrname = scrname||pscr

/* parse command line options, to enable calling the script automatically,
 * eg. from a function key. This gets priority over global settings!
 */

if inname ~= "" then do
  if inname = "QUIET" | inname = "NOREQ" then do
    inval = inname; inname = ""
  end
end

if inval = "QUIET" then do
  outp = 0; usereq = 0
end
else if inval = "NOREQ" then usereq = 0

if usereq & ~show('l','rexxreqtools.library') then do
  if exists('libs:rexxreqtools.library') then
    call addlib('rexxreqtools.library',0,-30,0)
  else do
    usereq = 0; outp = 1
    Tell("Unable to open rexxreqtools.library - using text output")
  end
end

if ~usereq then prgrs = 0

if prgrs & ~show('l','rexxarplib.library') then do
  if exists('libs:rexxarplib.library') then
    call addlib('rexxarplib.library',0,-30,0)
  else
    prgrs = 0
end

screentofront(pscr)

/* Originally stolen from Peter Billing - thanks Peter ;-) */
if ~show('P','SCIONGEN') then do
  EndString('I am sorry to say that the SCION Genealogist' || NL ||,
    'database is not available. Please start the' || NL ||,
    'SCION program BEFORE using this script!')
end

myport = "SCIONGEN"
address value myport
GETDBNAME
dbname = upper(RESULT)

if outp & ~usereq then do
  if pscr ~= "WORKBENCH" then do
    scrdev = 'SCNG2SSCR'
    if ~open(scrdev, scrname, 'w') then scrdev = stdout
  end
  Tell("GEDCOM to Scion conversion script v"||versionstr||" by Freddy Ariës")
  Tell("Scion (output) database: "||dbname)
end

if inname = "" then do
  /* ignore the value of outp; if we can't ask for the input file,
   * we can't do anything!
   */
  if usereq then do
    /* We need a file requester for further data */
    inname = rtfilerequest(,,'GEDCOM Input File',,'rt_pubscrname = '||PSCR||'   rtfi_initialpath = RAM:',)
  end
  else do
    Tell("Please enter the filename (with complete path) of the GEDCOM file:")
    TellNN("Input file: ")
    inname = readln(scrdev)
    inname = strip(inname, 'b', ' "')
  end
  if inname = '' then
    EndString("ERROR: No Input File!")
end

if ~open(infile, inname, "r") then
  EndString("ERROR: Input file '"inname"' not found!")

if outp then do
  if usereq then do
    donotes = rtezrequest("Create external Note files for Scion for "||,
              NL||'long GEDCOM comment lines?'||,
              '',' _Yes| _No ','Input Request:','rt_pubscrname = '||pscr)
    if donotes then do
      prstot='Scion Database name: '||dbname||NL
      if notesdir~="" then do
        prstot=prstot||'Scion Notes directory: '||NL||'"'||notesdir||'"'||NL
        prstot=prstot||'The Note files will be created using this name,'||NL
        prstot=prstot||'and in this directory.'||NL
      end
      else
        prstot=prstot||'The Note files will be created using this name.'||NL
      prstot=prstot||'If that is not what you want, abort and save'||NL
      prstot=prstot||'your (possibly empty) database first under a'||NL
      prstot=prstot||'different name! '||NL||'    Please make your choice: '
      docont = rtezrequest(prstot,' _Continue | _Abort ','Converter Message:','rt_pubscrname = '||PSCR)
      if docont = 0 then EXIT; /* EndString("Aborted!") */
      if notesdir = "" then do
        notesdir = rtfilerequest(,,'Select Notes Directory:','_Ok','rt_pubscrname = '||pscr||'   rtfi_flags = freqf_nofiles   rtfi_initialpath = RAM:',fres)
        if fres = 0 then donotes = 0
          /* User cancelled requester: no external note files will be created */
        /* For future use:
        if donotes then do
          ntovw = rtezrequest('Overwrite existing note files?'||,
            '',' _Yes | _No ','Converter Message:','rt_pubscrname = '||PSCR)
        end
     */
      end
    end
  end
  else do
    Tell("Create external Note files for Scion for long")
    TellNN("GEDCOM comment lines (y/n)? ")
    innote = readln(scrdev)
    innote = upper(left(innote, 1))
    if innote = "Y" then donotes = 1
    else donotes = 0
    Tell("")
    if donotes then do
      innote = ""
      do until innote = "Y" | innote = "N"
        Tell("Scion Database name: "||dbname)
        if notesdir ~= "" then do
          Tell("Scion Notes directory: "||NL||'"'||notesdir||'"')
          Tell("The Note files will be created using this name,")
          Tell("and in this directory.")
        end
        else
          Tell("The Note files will be created using this name.")
        Tell("If that is not what you want, abort and save your")
        Tell("(possibly empty) database first under a different name!")
        TellNN("Continue (y/n): ")
        innote = readln(scrdev)
        innote = upper(left(innote, 1))
      end
      if innote ~= "Y" then EndString("Aborted.")
      if notesdir = "" then do
        ptmp = ""
        do until ptmp = ":" | ptmp = "/"
          Tell("Enter full directory name where Scion's note files are located")
          TellNN("(MUST end with ':' or '/'): ")
          innote = readln(scrdev)
          innote = strip(innote, 'b', ' "')
          ptmp = right(innote, 1)
        end
        notesdir = innote
      end
      /* For future use:
      TellNN("Overwrite existing Note files? (y/n): ")
      innote = readln(scrdev)
      innote = upper(left(innote, 1))
      if innote = "Y" then ntovw = 1
      else ntovw = 0
      */
    end
  end
end

ntovw = 1

if ~usereq then
  Tell("Be patient - this may take a while...")

/* Initialize line count, individual counter and family counter */
ink = GetNextLine()
if left(ink, 6) ~= "0 HEAD" then do
  close(infile)
  EndString("ERROR: Invalid beginning of file - not a valid GEDCOM format")
end

lvlstr = '0'; lvl = 1; atlvl = 1
IRNArr.0 = ''; IRNArr.1 = ''; FGRNArr.0 = ''; FGRNArr.1 = ''

/* Read the "HEAD(ER)" section until we find something else of level "0" */

prstot = ""
ink = ParseHeader(atlvl)
GETPROGVERSION
prsr = RESULT
prsr = "Destination: Scion Genealogist "||prsr
if ~usereq then
  Tell(prsr)
else
  prstot = prstot||prsr||NL
prsr = "Dest. file:  "||dbname
if ~usereq then
  Tell(prsr||NL||"Scanning file for persons...")
else do
  prstot=prstot||prsr||NL||NL||"Parsing will take a while - be patient."||,
    NL||"Click `Continue' to start parsing..."
  rv = rtezrequest(prstot,'_Continue| _Abort ','Converter Message:','rt_pubscrname = '||PSCR)
  if rv = 0 then EXIT
end

/* TO DO: if inname ends on .GED, strip the extension */
if ~open(errfile, inname||".log", "w") then
  errfile = stdout

/* Now scan the following level "0" fields for individuals;
 * skip the families, for the moment
 */

irn = 0; famline = 0

if prgrs then do
  Postmsg(10, 10, "GEDCOM to Scion (by Freddy Ariës)\Database: "||,
    StripPath(inname)||"\Persons parsed: "||irn||"\ ", PSCR)
  pgopen = 1
end

replay = 0
do while ~eof(infile)
  lvlstr = word(ink, 1)
  lvl = GetNumType(lvlstr)

  if lvl = atlvl then do
    tagstr = upper(word(ink, words(ink)))
    if (tagstr="INDI" | tagstr="INDIVIDUAL") then do
      nstr = compress(word(ink, 2), '@ ')
      tp = GGetIRN(nstr)
      if tp ~= 0 then
        writeln(errfile, "ERROR: Duplicate person encountered: "||nstr||" (IRN "||tp||") (line: "||lnum||")")
      irn = irn + 1
      if pgopen then Postmsg(,, "\\Persons parsed: "||irn||"\ ", PSCR)
      ink = ParsePerson(nstr, lvl)
      if ink ~= "" then replay = 1
    end
    else if ((tagstr="FAM" | tagstr="FAMILY") & famline = 0) then
      famline=lnum
  end
  /* Skip all lines with level ~= current level (0) */
  if replay = 0 then ink = GetNextLine()
  else replay = 0
end

if ~usereq then
  Tell("Number of persons parsed: "||irn)

/* Now rescan the entire file for FAMilies; I know it is quite
 * inefficient this way, but it's better to add all the persons first,
 * and then establish the relations...
 */

replay = 0
fgrn = 0; fxs = 0

if ~usereq then
  Tell("Scanning file again to establish relations...")

if pgopen then Postmsg(,, "\\\Families parsed: 0 (scanning...)", PSCR)

/* If we've already passed the first FAM line, go back to that line
 * in the file. Otherwise, just continue where we are.
 */
if famline > 0 then do
  famline = famline - 1
  close(infile)
  if ~open(infile, inname, 'r') then
    EndString("ERROR: Unable to read relations!")
  lvlstr = '0'; lvl = 1; atlvl = 1; lnum = 0
  do while ~eof(infile) & lnum < famline
    lnum = lnum + 1
    ink = readln(infile)
  end
end

do while ~eof(infile)
  if replay = 0 then ink = GetNextLine()
  else replay = 0

  lvlstr = word(ink, 1)
  lvl = GetNumType(lvlstr)

  if lvl = atlvl then do
    tagstr = upper(word(ink, words(ink)))
    if (tagstr = "FAM" | tagstr = "FAMILY") then do
      nstr = compress(word(ink, 2),'@ ')
      fp = GGetFGRN(nstr)
      if fp ~= 0 then
        writeln(errfile, "WARNING: Duplicate family encountered: "||nstr||" (FGRN "||fp||") (line: "||lnum||")")
        /* TO DO: is the error message necessary? Or can we simply go on? */
      else
        fgrn = fgrn + 1
      if pgopen then Postmsg(,, "\\\Families parsed: "||fgrn, PSCR)
      ink = ParseFamily(nstr, lvl)
      if ink ~= "" then replay = 1
    end
    else if (tagstr = "TRLR" | tagstr = "TRAILER") then do
      close(infile)
      if pgopen then do
        Postmsg()
        pgopen = 0
      end
      if usereq then do
        EndString("PARSING DONE:"||NL||"Number of persons parsed: "||irn||,
          NL||"Number of families parsed: "||fgrn||,
      NL||NL||"DON'T FORGET TO SAVE YOUR SCION FILE!!!")
      end
      else do
    EndString("Number of families parsed: "||fgrn||NL||,
           NL||"DONE! DON'T FORGET TO SAVE YOUR SCION FILE!!!")
      end
    end
  end
  /* Skip all the fields at lvl ~= this level */
end
close(infile)
if (ink ~= "0 TRLR") & (ink ~= "0 TRAILER") then
  EndString("ERROR: Unexpected end of file")
else
  EndString("ERROR: Trailer not recognized! (line: "||lnum||")")

ParseHeader: PROCEDURE EXPOSE infile prstot NL outp usereq scrdev lnum pgopen pscr
parse arg inilvl
do while ~eof(infile)
  ins = GetNextLine()
  if ins = "" then
    EndString("ERROR: Unexpected end of file")
  lvlstr = word(ins, 1)
  lvl = GetNumType(lvlstr)
  if lvl <= inilvl then RETURN ins
  if lvl = inilvl+1 then do
    lstr = strip(delstr(ins, 1, length(lvlstr)))
    if left(curr,4) = "SOUR" then do
      lstr = strip(delstr(lstr, 1, length(curr)))
      prsr = "Source system: "||lstr
      if ~usereq then
    Tell(prsr)
      else
        prstot = prstot||prsr||NL
      ins = ParseSource(lvl)
      lvlstr = word(ins, 1)
      lvl = lvlstr + 1
      if lvl <= inilvl then RETURN ins
      if lvl = inilvl+1 then do
        lstr = strip(delstr(ins, 1, length(lvlstr)))
        curr = upper(word(lstr, 1))
      end
      else EndString("ERROR: This should never happen [1] (line: "||lnum||")")
    end
    if curr = "DATE" then do
      lstr = strip(delstr(lstr, 1, length(curr)))
      prsr = "Creation date: "||lstr
      if ~usereq then
    Tell(prsr)
      else
        prstot = prstot||prsr||NL
    end
    else if curr = "FILE" then do
      lstr = strip(delstr(lstr, 1, length(curr)))
      prsr = "Source file:   "||lstr
      if ~usereq then
    Tell(prsr)
      else
        prstot = prstot||prsr||NL
    end
    /* add COPR (copyright) and GEDC VERS parsing
     */
  end
end
EndString("ERROR: Unexpected end of file")

ParseSource: PROCEDURE EXPOSE infile prstot NL outp usereq scrdev lnum pgopen pscr
parse arg namlvl
/* Scan for "NAME" and "VERS" */
do while ~eof(infile)
  ins = GetNextLine()
  if ins = "" then
    EndString("ERROR: Unexpected end of file")
  lvlstr = word(ins, 1)
  lvl = GetNumType(lvlstr)
  if lvl <= namlvl then RETURN ins
  if lvl = namlvl+1 then do
    lstr = strip(delstr(ins, 1, length(lvlstr)))
    curr = left(upper(word(lstr, 1)),4)
    if curr = "VERS" then do
      lstr = strip(delstr(lstr, 1, length(curr)))
      prsr = "Version:       "||lstr
      if ~usereq then
        Tell(prsr)
      else
        prstot = prstot||prsr||NL
    end
    else if curr = "NAME" then do
      lstr = strip(delstr(lstr, 1, length(curr)))
      prsr = "Created by:    "||lstr
      if ~usereq then
        Tell(prsr)
      else
        prstot = prstot||prsr||NL
    end
  end
end
EndString("ERROR: Unexpected end of file")

ParsePerson: PROCEDURE EXPOSE infile IrnArr. errfile outp usereq scrdev lnum donotes dbname ntovw notesdir pgopen pscr
parse arg pnum, inilvl
replay = 0
prn = GetNewPerson()
IRNArr.0 = IRNArr.0||pnum||' '
IRNArr.1 = IRNArr.1||prn||' '
noteset = 0; refset = 0; oldnotestr = ""
do while ~eof(infile)
  if replay = 0 then ins = GetNextLine()
  else replay = 0
  if ins = "" then
    EndString("ERROR: Unexpected end of file")

  lvlstr = word(ins, 1)
  lvl = GetNumType(lvlstr)
  if lvl <= inilvl then RETURN ins
  if lvl = inilvl + 1 then do
    lstr = strip(delstr(ins, 1, length(lvlstr)))
    curr = upper(word(lstr, 1))
    restcurr = delstr(lstr, 1, length(curr))
    if curr="FAMILY_CHILD" then curr = "FAMC"
    else if curr="FAMILY_SPOUSE" then curr = "FAMS"
    else if curr = "REFERENCE" then curr = "REFN"
    else if curr = "CHRISTENING" | curr = "ADULT_CHRISTENING" then curr = "CHR"
    else if length(curr) > 4 then curr = left(curr, 4)
  end

  if curr = "NAME" then StorePersName(strip(restcurr), prn)
  else if curr = "SEX" then StorePersSex(strip(restcurr), prn)
  else if (curr="BIRT" | curr="DEAT" | curr="BURI" | curr="CHR" | curr="BAPM" | curr="BAPL" | curr="CHRA" | curr="CONF" | curr = "BAPT") then
  do
    if left(curr,3) = "BAP" then curr = "BAP"
    else if left(curr,3) = "CHR" then curr = "CHR"
    /* note that BAPT is not official GEDCOM standard, but is for
     * compatibility with long-form tags BAPTISM and BAPTISM-LDS, which are
     * treated the same anyway.
     */
    ins = ParsePersDatePlace(curr, prn, lvl)
    replay = 1
  end
  else if curr = "OCCU" then StoreOccup(strip(restcurr), prn)
  else if curr = "EDUC" then StoreEduc(strip(restcurr), prn)
  else if curr = "RELI" then StoreRelig(strip(restcurr), prn)
  else if curr = "STIL" then StoreCOD("stillborn", prn)
    /* Note: 'STIL' is not yet part of the official GEDCOM standard */
  else if curr = "NOTE" then do
    if lvl > inilvl + 1 then do
      ntstr = strip(delstr(ins, 1, length(lvlstr)))
      ntcurr = left(upper(word(ntstr, 1)),4)
      notestr = delstr(ntstr, 1, length(ntcurr)+1)
    end
    else do
      ntstr = lstr
      ntcurr = curr
      notestr = delstr(restcurr, 1, 1)
    end
    /* In both cases above, we only strip the first leading blank (which
     * is the delimiter), and leave other leading blanks untouched.
     */
    if noteset = 0 then do
      StorePersComment(notestr, prn)
      oldnotestr = notestr
      noteset = 1
    end
    else if donotes & (ntcurr = "NOTE" | ntcurr = "CONT" | ntcurr = "CONC") then do
      nfname = notesdir||"PN"||prn||"."||dbname
      if noteset = 1 then do
        if ~ntovw then do
      DoAppend(nfname, oldnotestr)
      DoAppend(nfname, notestr)
        end
    else if open(notefile, nfname, 'w') then do
      writeln(notefile, oldnotestr)
      writeln(notefile, notestr); /* append new string */
      close(notefile)
    end
        StorePersComment("[see notes]", prn)
        noteset = 2
      end
      else
    DoAppend(nfname, notestr); /* noteset = 2 => always append */
    end
    else
      writeln(errfile, "SKIPPED: Level "||lvlstr||" field "||ntcurr||" for person "||pnum||"! (line: "||lnum||")")
  end
  else if curr = "SOUR" then do
    prline = strip(restcurr)
    if ~refset then do
      if prline ~= "" then do
        prline = strip(prline,'b','@')
        StorePersRefs(prline, prn)
        refset = 1
      end
    end
    else do
      lostr = upper(word(strip(delstr(ins, 1, length(lvlstr))), 1))
      writeln(errfile, "SKIPPED: Level "||lvlstr||" field "||lostr||" for person "||pnum||"! (line: "||lnum||")")
    end
  end
  else if (curr="FAMC" | curr="FAMS" | curr="NUMB") then do
    /* nothing - children and spouse relationships are established later
     * and NUMB fields are considered to be irrelevant (are not even
     * part of the official GEDCOM specification, btw)
     * Note: we do not output a "Skipped" message for these fields.
     */
  end
  else if (curr = "CHAN" | curr = "REFN") then do
    ins = SkipChanged(lvl)
    replay = 1
    /* no 'SKIPPED' message for these fields */
  end
  else do
    olv = lvl - 1
    writeln(errfile, "SKIPPED: Level "||olv||" field "||curr||" for person "||prn||"! (line: "||lnum||")")
  end
end
EndString("ERROR: Unexpected end of file")

ParseFamily: PROCEDURE EXPOSE infile errfile outp usereq scrdev lnum fline flcnt FFile. FGRNArr. IRNArr. donotes dbname ntovw notesdir pgopen pscr
parse arg fnum, inilvl
replay = 0; fxs = 0; fins = 0
finp = 0; flcnt = 0; fline = 0; FFile. = ""
noteset = 0; refset = 0; oldnotestr = ""

/* replay: parse the currently read line, don't read the next one
 * fxs   : family exists; if 0, only allow HUSB and WIFE, rest to temp-array
 *       ~= 0, then contains FGRN (family number)
 * finp  : file input; 0 = from sourcefile (GEDCOM), 1 = from temp-array
 * fline : currently parsed line in temp-array / flcnt : max number of lines
 * FFile : the temporary array used for this
 */

do while (finp = 0 & ~eof(infile)) | (finp = 1 & (fline <= flcnt))
  if replay = 0 then ins = GetNextFLine(finp)
  else
    replay = 0

  if ins = "" & finp = 0 then
    EndString("ERROR: Unexpected end of file!")

  if finp = 1 & (fline > flcnt) then RETURN fins

  lvlstr = word(ins, 1)
  lvl = GetNumType(lvlstr)
  if (lvl <= inilvl) & (finp = 0) then do
    if flcnt = 0 then RETURN ins
    finp = 1; fline = 0
    fins = ins; /* backup the currently read line */
    ITERATE
  end
  if lvl = inilvl + 1 then do
    lstr = strip(delstr(ins, 1, length(lvlstr)))
    curr = upper(word(lstr, 1))
    restcurr = delstr(lstr, 1, length(curr))
    prsid = compress(restcurr, ' @')
    if curr = "DIVORCE" then curr = "DIV"
    else if curr="ANNULMENT" then curr = "ANUL"
    else if curr="REFERENCE" then curr = "REFN"
    else if length(curr) > 4 then curr = left(curr, 4)
  end

  if curr="HUSB" then fxs = StoreFamHusband(prsid, fnum)
  else if curr = "WIFE" then fxs = StoreFamWife(prsid, fnum)
  else if curr="CHIL" then do
    if lvl > inilvl + 1 then do
      olv = lvl - 1
      lostr = left(upper(word(strip(delstr(ins, 1, length(lvlstr))), 1)), 4)
      if lostr = "ADOP" then
        StoreChildAdopt(prsid)
      else
        writeln(errfile, "SKIPPED: Level "||olv||" field "||lostr||" for family "||fnum||"! (line: "||lnum||")")
      ITERATE
    end
    if fxs = 0 then do
      if finp = 1 then
        writeln(errfile, "ERROR: Family does not exist for "||lstr||" !")
      else
        FOutput(ins)
    end
    else StoreFamChild(prsid, fxs)
  end
  else if (curr="MARR" | curr="DIV" | curr="ANUL" | curr="ENGA") then do
    if fxs = 0 then do
      if finp = 1 then
        writeln(errfile, "ERROR: Family does not exist for "||lstr||" !")
      else
        FOutput(ins)
    end
    ins = ParseFamDatePlace(curr, fxs, lvl, upper(prsid), finp)
    if ins ~= 0 then replay = 1
  end
  else if curr = "NOTE" then do
    if lvl > inilvl + 1 then do
      ntstr = strip(delstr(ins, 1, length(lvlstr)))
      ntcurr = left(upper(word(ntstr, 1)),4)
      notestr = strip(delstr(ntstr, 1, length(ntcurr)))
    end
    else do
      ntstr = lstr
      ntcurr = curr
      notestr = strip(restcurr)
    end
    if noteset = 0 then do
      if fxs ~= 0 then do
        StoreFamComment(notestr, fxs)
        oldnotestr = notestr
        noteset = 1
      end
      else do
        if finp = 1 then
          writeln(errfile, "ERROR: Family does not exist for "||ntstr||" !")
        else
          FOutput(ins)
      end
    end
    else if donotes & (ntcurr = "NOTE" | ntcurr = "CONT" | ntcurr = "CONC") then do
      /* only called if noteset = 1, thus fxs ~= 0 */
      if fxs ~= 0 then do
        nfname = notesdir||"FN"||fxs||"."||dbname
        if noteset = 1 then do
          if ~ntovw then do
        DoAppend(nfname, oldnotestr)
        DoAppend(nfname, notestr)
          end
      else if open(notefile, nfname, 'w') then do
        writeln(notefile, oldnotestr)
        writeln(notefile, notestr); /* append new string */
        close(notefile)
      end
          StoreFamComment("[see notes]", fxs)
      noteset = 2
        end
        else
      DoAppend(nfname, notestr); /* noteset = 2 => always append */
      end
      else
        writeln(errfile, "ERROR: Family for "||ntstr||" doesn't exist!")
    end
    else
      writeln(errfile, "SKIPPED: Level "||lvlstr||" field "||ntcurr||" for family "||fnum||"! (line: "||lnum||")")
  end
  else if curr = "SOUR" then do
    frline = strip(restcurr)
    if ~refset then do
      if frline ~= "" then do
    frline = strip(frline,'b','@')
    if fxs ~= 0 then do
      PUTFAMREFS fxs frline
      refset = 1
        end
    else do
      if finp = 1 then
        writeln(errfile, "ERROR: Family does not exist for "||lstr||" !")
      else
        FOutput(ins)
    end
      end
    end
    else do
      lostr = upper(word(strip(delstr(ins, 1, length(lvlstr))), 1))
      writeln(errfile, "SKIPPED: Level "||lvlstr||" field "||lostr||" for family "||fnum||"! (line: "||lnum||")")
    end
  end
  else if curr = "NUMB" | curr = "REFN" then do
    /* No SKIPPED message for these fields, as they are irrelevant.
     * NUMB fields are not even part of the official GEDCOM specification.
     * It's just here because eg. ROOTS uses them a lot, and I don't want
     * the program to output a "SKIPPED" line for them in the log file.
     */
  end
  else if curr = "CHAN" then do
    ins = SkipChanged(lvl)
    replay = 1
    /* no 'SKIPPED' message for these fields */
  end
  else do
    olv = lvl - 1
    writeln(errfile, "SKIPPED: Level "||olv||" field "||curr||" in family "||fnum||"! (line: "||lnum||")")
  end
end
if finp = 1 then RETURN fins
EndString("ERROR: Unexpected end of file!")

GetNumType: PROCEDURE EXPOSE outp infile usereq lnum pgopen pscr scrdev
parse arg str
if ~DATATYPE(str, 'w') then
  EndString("ERROR: Level indicator expected -> error in GEDCOM specification?"||'0A'x||"String is "||str||" (line: "||lnum||")")
return str + 1

GetNextFLine: PROCEDURE EXPOSE infile fline flcnt lnum FFile.
parse arg finp
if finp = 0 then return GetNextLine()
ignl = ""
do while ignl = "" & fline <= flcnt
  fline = fline + 1
  ignl = FFile.fline
  if ignl ~= "" then ignl = strip(ignl, 'B', '
')
  /* strip leading and trailing spaces, tabs and ^M (linefeed) characters */
  /* also skip empty lines */
end
return ignl

GetNextLine: PROCEDURE EXPOSE infile lnum
lnum = lnum + 1
ignl = ""
do while ignl = "" & ~eof(infile)
  ignl = readln(infile)
  if ignl ~= "" then ignl = strip(ignl, 'B', '
')
  /* strip leading and trailing spaces, tabs and ^M (linefeed) characters */
  /* also skip empty lines */
end
return ignl

FOutput: PROCEDURE EXPOSE flcnt FFile.
parse arg iline
FFile.flcnt = iline
flcnt = flcnt + 1
return 0

StorePersName: PROCEDURE
parse arg nstr, pnum
nstr = strip(nstr, 'B', '/')
ps = pos('/', nstr)
if ps = 0 then do
  fname = ""
  lname = nstr
end
else do
  fname = left(nstr, ps-1)
  lname = compress(right(nstr, length(nstr)-ps),'/')
end
PUTLASTNAME pnum lname
PUTFIRSTNAME pnum fname
return 1

StorePersSex: PROCEDURE
parse arg nstr, pnum
 sxstr = upper(left(nstr, 1))
 if sxstr ~= 'M' then sxstr = 'F'
PUTSEX pnum sxstr
return 1

ParsePersDatePlace: PROCEDURE EXPOSE infile errfile outp usereq scrdev lnum pgopen pscr
parse arg idstr, pnum, inilvl
datstr = ""
plcstr = ""
causestr = ""
do while ~eof(infile)
  ins = GetNextLine()
  if eof(infile) then
    EndString("ERROR: Unexpected end of file!")
  lvlstr = word(ins, 1)
  lvl = GetNumType(lvlstr)
  if lvl <= inilvl then do
    select
      when idstr = "BIRT" then do
    if datstr ~= "" then
      PUTBIRTHDATE pnum datstr
    if plcstr ~= "" then
      PUTBIRTHPLACE pnum plcstr
      end
      when idstr = "DEAT" then do
    if datstr ~= "" then
      PUTDEATHDATE pnum datstr
    if plcstr ~= "" then
      PUTDEATHPLACE pnum plcstr
    if causestr ~= "" then
      PUTDIEDOF pnum causestr
      end
      when idstr = "BURI" then do
    if datstr ~= "" then
      PUTBURIALDATE pnum datstr
    if plcstr ~= "" then
      PUTBURIALPLACE pnum plcstr
      end
      when (idstr="BAP" | idstr="CHR" | idstr="CONF") then do
    if datstr ~= "" then
      PUTBAPTISMDATE pnum datstr
    if plcstr ~= "" then
      PUTBAPTISMPLACE pnum plcstr
      end
      otherwise
        /* do nothing */
    end
    RETURN ins
  end
  else if lvl = inilvl+1 then do
    lstr = strip(delstr(ins, 1, length(lvlstr)))
    curr = upper(word(lstr, 1))
    if curr = "DATE" then do
      datstr = strip(delstr(lstr, 1, length(curr)))
      /* TO DO: add some more parsing of the date string
       * - dates ending on /x (indicating a choice of years)
       * - "BET" dates (between 2 dates)
       * etc.
       */
    end
    else if (curr="PLAC" | curr="PLACE") then do
      plcstr = strip(delstr(lstr, 1, length(curr)))
    end
    else if (curr="QUAY" | curr="QUALITY_OF_DATA") then do
      /* only add '?' for QUAY 0 fields */
      lstr = strip(delstr(lstr, 1, length(curr)))
      if DATATYPE(lstr, 'w') & lstr < 1 then do
        if datstr ~= "" then datstr = datstr||'?'
        if plcstr ~= "" then plcstr = plcstr||'?'
      end
    end
    else if (curr="CAUS" | curr="CAUSE") then do
      causestr = strip(delstr(lstr, 1, length(curr)))
    end
  end
  else do
    /* lvl > inilvl+1 */
    qlstr = strip(delstr(ins, 1, length(lvlstr)))
    qcurr = upper(word(qlstr, 1))
    if (qcurr="QUAY" | qcurr="QUALITY_OF_DATA") then do
      /* only add '?' for QUAY 0 fields */
      qlstr = strip(delstr(qlstr, 1, length(qcurr)))
      if DATATYPE(qlstr, 'w') & qlstr < 1 then do
        if curr = "DATE" & datstr ~= "" then
      datstr = datstr||'?'
        if (curr = "PLAC" | curr = "PLACE") & plcstr ~= "" then
      plcstr = plcstr||'?'
      end
    end
    else do
      /* else: skip all other fields of level inilvl+1 */
      writeln(errfile, "SKIPPED: Level "||lvlstr||" field "||qcurr||" for person "||pnum||"! (line: "||lnum||")")
    end
  end
end
return 0

ParseFamDatePlace: PROCEDURE EXPOSE infile errfile outp usereq scrdev lnum fline flcnt pgopen pscr FFile. FGRNArr.
parse arg idstr, ff, inilvl, idr, finp
datstr = ""; plcstr = ""; clbrnt = ""; wtness = ""
if idstr="ANUL" then divtype = 4
else if (idr = "N" & idstr="DIV") then divtype = 1
else divtype = 2
/* some programs (like PAF 2.2) have "DIV Y" and "DIV N" fields
 * DIV Y (yes) is treated identical to "DIV" (without arguments)
 * DIV N (no)  is treated as 'Ending: None'
 */
do while ~eof(infile) | (fline < flcnt)
  ins = GetNextFLine(finp)

  if finp = 0 & ins = "" then
    EndString("ERROR: Unexpected end of file (Parsing Family Events)!")

  if finp = 1 & (fline > flcnt) then do
    if ff ~= 0 then do
      if idstr="MARR" then do
        if datstr ~= "" then
        PUTMARRYDATE ff datstr
        if plcstr ~= "" then
        PUTMARRYPLACE ff plcstr
        if clbrnt ~= "" then
          PUTCELEBRANT ff clbrnt
        if wtness ~= "" then
          PUTWITNESS ff wtness
      end
      else if (idstr="ANUL" | idstr="DIV") then do
        if datstr ~= "" then
        PUTENDDATE ff datstr
        if plcstr ~= "" then
        PUTENDPLACE ff plcstr
    PUTENDING ff divtype
      end
      else if idstr="ENGA" then do
        if datstr ~= "" then
        PUTENGAGEDATE ff datstr
        if plcstr ~= "" then
        PUTENGAGEPLACE ff plcstr
      end
    end
    RETURN 0
  end

  lvlstr = word(ins, 1)
  lvl = GetNumType(lvlstr)
  if lvl <= inilvl then do
    if ff ~= 0 then do
      if idstr="MARR" then do
        if datstr ~= "" then
      PUTMARRYDATE ff datstr
        if plcstr ~= "" then
      PUTMARRYPLACE ff plcstr
        if clbrnt ~= "" then
          PUTCELEBRANT ff clbrnt
        if wtness ~= "" then
          PUTWITNESS ff wtness
      end
      else if (idstr="DIV" | idstr="ANUL") then do
        if datstr ~= "" then
        PUTENDDATE ff datstr
        if plcstr ~= "" then
        PUTENDPLACE ff plcstr
        PUTENDING ff divtype
      end
      else if idstr="ENGA" then do
        if datstr ~= "" then
        PUTENGAGEDATE ff datstr
        if plcstr ~= "" then
        PUTENGAGEPLACE ff plcstr
      end
    end
    RETURN ins
  end
  if finp = 0 & ff = 0 then FOutput(ins)
  else do
    if lvl = inilvl+1 then do
      lstr = strip(delstr(ins, 1, length(lvlstr)))
      curr = upper(word(lstr, 1))
      if curr="QUALITY_OF_DATA" then curr = "QUAY"
      else if length(curr) > 4 then curr = left(curr, 4)
      if curr = "DATE" then do
        datstr = strip(delstr(lstr, 1, length(curr)))
        /* TO DO: add some more parsing of the date string */
      end
      else if curr="PLAC" then do
        plcstr = strip(delstr(lstr, 1, length(curr)))
      end
      else if curr="OFFI" then do
        clbrnt = strip(delstr(lstr, 1, length(curr)))
        /* only for "MARR" */
      end
      else if curr="WITN" then do
        wtness = strip(delstr(lstr, 1, length(curr)))
        /* only for "MARR" */
      end
      else if curr="QUAY" then do
        /* only add '?' for QUAY 0 fields */
        lstr = strip(delstr(lstr, 1, length(curr)))
        if DATATYPE(lstr, 'w') & lstr < 1 then do
          if datstr ~= "" then datstr = datstr||'?'
          if plcstr ~= "" then plcstr = plcstr||'?'
        end
      end
      else if (curr = "TYPE" & idstr = "DIV") then do
        lstr = upper(strip(delstr(lstr, 1, length(curr))))
        if left(lstr, 3) = "SEP" then divtype = 3
        else if left(lstr, 4) = "DEAT" then divtype = 5
        else divtype = 2
        /* default is 'DIVORCE' */
      end
    end
    else if lvl > inilvl + 1 then do
      qlstr = strip(delstr(ins, 1, length(lvlstr)))
      qcurr = upper(word(qlstr, 1))
      if (qcurr="QUAY" | qcurr="QUALITY_OF_DATA") then do
        /* only add '?' for QUAY 0 fields */
        qlstr = strip(delstr(qlstr, 1, length(qcurr)))
        if DATATYPE(qlstr, 'w') & qlstr < 1 then do
          if curr = "DATE" & datstr ~= "" then
        datstr = datstr||'?'
          if curr = "PLAC" & plcstr ~= "" then
        plcstr = plcstr||'?'
        end
      end
      else do
        /* else: skip all other fields of level inilvl+1 */
        writeln(errfile, "SKIPPED: Level "||lvlstr||" field "||qcurr||" for family "||ff||"! (line: "||lnum||")")
      end
    end
  end
end
EndString("ERROR: Unexpected end of file (Parsed Family Events)!")

GetNewPerson: PROCEDURE EXPOSE infile outp usereq scrdev pgopen pscr
  PUTNEWPERSON
  newpnum = RESULT
  if newpnum = 0 then EndString("ERROR: Cannot allocate new person!")
  /* if you want to see Scion in action, uncomment the next line */
  /* GETPERSONWIN newpnum */
return newpnum

GetNewFamily: PROCEDURE EXPOSE infile outp usereq scrdev pgopen pscr
parse arg irn
  PUTNEWFAMILY irn
  newfnum = RESULT
  if newfnum = 0 then EndString("ERROR: Cannot allocate new family!")
  /* if you want to see Scion in action, uncomment the next line */
  /* GETFAMILYWIN newfnum */
return newfnum

StoreOccup: PROCEDURE
parse arg nstr, pnum
 PUTOCCUPATION pnum nstr
return 1

StoreEduc: PROCEDURE
parse arg nstr, pnum
 PUTEDUCATION pnum nstr
return 1

StoreRelig: PROCEDURE
parse arg nstr, pnum
 PUTRELIGION pnum nstr
return 1

StoreCOD: PROCEDURE
parse arg nstr, pnum
 PUTDIEDOF pnum nstr
return 1

StorePersComment: PROCEDURE
parse arg nstr, pnum
  if pnum ~= 0 then
    PUTPERSCOMMENT pnum nstr
return 1

StorePersRefs: PROCEDURE
parse arg nstr, pnum
  if pnum ~= 0 then
    PUTPERSREFS pnum nstr
return 1

StoreFamHusband: PROCEDURE EXPOSE errfile infile outp usereq scrdev lnum IRNArr. FGRNArr.
parse arg nstr, fnum
  nstr = compress(nstr,'@ ')
  ff = 0
  ii = GGetIRN(nstr)
  if ii = 0 then
    writeln(errfile, "ERROR: Missing Personal Record for HUSBAND "||nstr||" (line: "||lnum||")")
  else do
    ff = GGetFGRN(fnum)
    if ff = 0 then do
    ff = GetNewFamily(ii)
    FGRNArr.0 = FGRNArr.0||fnum||' '
    FGRNArr.1 = FGRNArr.1||ff||' '
    end
    else do
    /* There already is a family, so there is a principal; assume
     * that that is the wife - add the husband as spouse
     */
      PUTSPOUSE ff ii
    ers = RESULT
    if ers ~= 1 then do
        writeln(errfile, "ERROR "||ers||" in PUTSPOUSE (HUSB) "||ff||' '||ii)
      GETPRINCIPAL ff
      prc = RESULT
      GETSPOUSE ff
      spc = RESULT
      writeln(errfile, "Principal: "||prc||", Spouse: "||spc)
    end
    end
  end
return ff

StoreFamWife: PROCEDURE EXPOSE errfile infile outp usereq scrdev lnum IRNArr. FGRNArr.
parse arg nstr, fnum
  nstr = compress(nstr,'@ ')
  ff = 0
  ii = GGetIRN(nstr)
  if ii = 0 then
    writeln(errfile, "ERROR: Missing Personal Record for WIFE "||nstr||" (line: "||lnum||")")
  else do
    ff = GGetFGRN(fnum)
    if ff = 0 then do
      ff = GetNewFamily(ii)
    FGRNArr.0 = FGRNArr.0||fnum||' '
    FGRNArr.1 = FGRNArr.1||ff||' '
    end
    else do
      PUTSPOUSE ff ii
    ers = RESULT
    if ers ~= 1 then do
        writeln(errfile, "ERROR "||ers||" in PUTSPOUSE (WIFE) "||ff||' '||ii)
      GETPRINCIPAL ff
      prc = RESULT
      GETSPOUSE ff
      spc = RESULT
      writeln(errfile, "Principal: "||prc||", Spouse: "||spc)
    end
    end
  end
return ff

StoreFamChild: PROCEDURE EXPOSE errfile infile outp usereq scrdev lnum IRNArr. FGRNArr.
parse arg nstr, fnum
/* TO DO: improve this function, to allow definition of children here,
 *      instead of in a separate personal record. Also look for "ADOP"
 *      field (adopted children)
 */
  if fnum = 0 then RETURN 0
    /* we cannot parse a child when there is no family yet */
  nstr = compress(nstr,'@ ')
  ii = GGetIRN(nstr)
  if ii = 0 then
    writeln(errfile, "ERROR: Missing Personal Record for CHILD "||nstr||" (line: "||lnum||")")
  else do
    PUTCHILD fnum ii
    ers = RESULT
    if ers ~= 1 then
      writeln(errfile, "ERROR "||ers||" in PUTCHILD "||fnum||' '||ii||" (line: "||lnum||")")
  end
return 1

StoreChildAdopt: PROCEDURE EXPOSE errfile infile outp usereq scrdev lnum IRNArr.
parse arg nstr
  /* This uses an as yet undocumented (and maybe even unsupported) feature
   * in Scion v4.07 and above.  So don't be surprised if you see italicized
   * names in the Family Details window (try alt-clicking on a child to
   * toggle this)
   */
  nstr = compress(nstr,'@ ')
  ii = GGetIRN(nstr)
  if ii = 0 then
    writeln(errfile, "ERROR: Missing Personal Record for CHILD "||nstr||" (line: "||lnum||")")
  else
    PUTADOPTION ii 1
return 1

StoreFamComment: PROCEDURE
parse arg nstr, ff
  PUTFAMCOMMENT ff nstr
return 1

/* Return the Scion IRN belonging to the GEDCOM Personal number pnum */
GGetIRN: PROCEDURE EXPOSE IRNArr.
parse arg pnum
anum = find(IRNArr.0, pnum)
if anum > 0 then
  return word(IRNArr.1, anum)
else
  return 0

/* Return the Scion FGRN belonging to the GEDCOM Family number fnum */
GGetFGRN: PROCEDURE EXPOSE lnum FGRNArr.
parse arg fnum
anum = find(FGRNArr.0, fnum)
if anum > 0 then
  return word(FGRNArr.1, anum)
else
  return 0

DoAppend: PROCEDURE
parse arg fname, ostr
if exists(fname) then
  rval = open(notefile, fname, 'a')
else
  rval = open(notefile, fname, 'w')
if rval then do
  writeln(notefile, ostr)
  close(notefile)
end
return 0

SkipChanged: PROCEDURE EXPOSE infile lnum
parse arg inlvl
lvl = inlvl + 1
do until lvl <= inlvl
  ins = GetNextLine()
  lvlstr = word(ins, 1)
  lvl = GetNumType(lvlstr)
end
return ins

/*
 * Procedure to strip the directory path from the string,
 * only leaving the filename
 */
StripPath: PROCEDURE
parse arg str
  p = lastpos('/', str)
  if p > 0 then ret1 = delstr(str,1,p)
  else ret1 = str
  p = lastpos(':', ret1)
  if p > 0 then retstr = delstr(ret1,1,p)
  else retstr = ret1
return retstr

Tell: PROCEDURE EXPOSE outp scrdev
parse arg str
if outp then writeln(scrdev, str)
return 0

TellNN: PROCEDURE EXPOSE outp scrdev
parse arg str
if outp then writech(scrdev, str)
return 0

EndString: PROCEDURE EXPOSE usereq outp pgopen pscr scrdev infile
parse arg str
if pgopen then Postmsg()
/* If you turned off stdout, no error messages will be shown! */
if usereq then
  rtezrequest(str,'E_xit','Converter Message:','rt_pubscrname = '||PSCR)
else
  Tell(str || '0A'x)
if outp & ~usereq & (scrdev ~= stdout) then do
  Tell("Press <return> to exit.")
  readln(scrdev)
  close(scrdev)
end
close(infile)
EXIT

/* Let's make sure you get a nice message when you turn off the printer :-) */

IOERR:
  bline = SIGL
  say "I/O error #"||RC||" detected in line "||bline||":"
  say sourceline(bline)
  if pgopen then Postmsg()
  EXIT